home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / examples / sketchpad.lisp < prev    next >
Encoding:
Text File  |  1991-06-25  |  11.6 KB  |  325 lines
  1. ;;; -*- Mode:Common-Lisp; Package:CLIO-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                             AUSTIN, TEXAS 78714-9149                             |
  9. ;;;                                                                                  |
  10. ;;;                Copyright (C) 1990 Texas Instruments Incorporated.                |
  11. ;;;                              All Rights Reserved                                 |
  12. ;;;                                                                                  |
  13. ;;; Use, duplication, or disclosure by the Government is subject to  restrictions as |
  14. ;;; set forth in subdivision (b)(3)(ii) of the Rights in Technical Data and Computer |
  15. ;;; Software clause at 52.227-7013.                                                  |
  16. ;;;                                                                                  |
  17. ;;;----------------------------------------------------------------------------------+
  18.  
  19.    
  20.  
  21.  
  22.  
  23.  
  24. (in-package "CLIO-EXAMPLES")
  25.  
  26. ;;;----------------------------------------------------------------------------+
  27. ;;;                                                                            |
  28. ;;;                                 sketchpad                                  |
  29. ;;;                                                                            |
  30. ;;;----------------------------------------------------------------------------+
  31.  
  32. (DEFCONTACT sketchpad (core contact)
  33.   ((mode          :type     (member :line :polygon)
  34.           :accessor sketchpad-mode
  35.           :initform :line)
  36.    (in-progress-p :type list
  37.                   :accessor sketchpad-in-progress-p
  38.                   :initform nil)   
  39.    (picture       :type list
  40.                   :accessor sketchpad-picture
  41.                   :initform nil)
  42.    (line-width    :type card16
  43.                   :accessor sketchpad-line-width
  44.                   :initform 0)
  45.    (fill          :type symbol
  46.                   :accessor sketchpad-fill
  47.                   :initform '100%gray)
  48.    (next-x        :type (or null int16)           
  49.                   :initform nil)
  50.    (next-y        :type (or null int16)           
  51.                   :initform nil)
  52.    (compress-exposures
  53.                   :allocation :class
  54.                   :initform   :on))
  55.   (:documentation "A basic picture editor.")
  56.   (:resources
  57.     (cursor      :initform 'crosshair-cursor)
  58.     (event-mask  :initform #.(make-event-mask :exposure :button-press))))
  59.  
  60.  
  61. (defun make-sketchpad (&rest initargs)
  62.   (apply #'make-contact 'sketchpad initargs))
  63.  
  64. ;;;----------------------------------------------------------------------------+
  65. ;;;                                                                            |
  66. ;;;                                  Display                                   |
  67. ;;;                                                                            |
  68. ;;;----------------------------------------------------------------------------+
  69.  
  70. (defmethod DISPLAY ((sketchpad sketchpad) &optional x y width height &key)
  71.   (with-slots
  72.     (picture (total-width width) (total-height height))
  73.     sketchpad
  74.     
  75.     (let*
  76.       ;; Compute default exposed area, if necessary.
  77.       ((x      (or x      0))
  78.        (y      (or y      0))
  79.        (width  (or width  (- total-width x)))
  80.        (height (or height (- total-height y))))
  81.  
  82.       ;; Draw all picture elements that intersect exposed area.
  83.       (dolist (element picture)
  84.         (when (intersect-p element x y width height)
  85.           (draw-element sketchpad element))))))
  86.  
  87.  
  88. ;;;----------------------------------------------------------------------------+
  89. ;;;                                                                            |
  90. ;;;                            Point-Seq Utilities                             |
  91. ;;;                                                                            |
  92. ;;;----------------------------------------------------------------------------+
  93.  
  94. (defmacro last-x (points)
  95.   `(first ,points))
  96.  
  97. (defmacro last-y (points)
  98.   `(second ,points))
  99.  
  100. (defmacro point-seq-length (points)
  101.   `(/ (length ,points) 2))
  102.  
  103. (defmacro point-seq-x (points i)
  104.    `(elt ,points (* ,i 2)))
  105.  
  106. (defmacro point-seq-y (points i)
  107.    `(elt ,points (1+ (* ,i 2))))
  108.  
  109. (defun nreverse-point-seq (point-seq)
  110.   (let ((rest (cddr point-seq)))
  111.     (cond
  112.       (rest
  113.     (setf (cddr point-seq) nil)
  114.     (nconc (nreverse-point-seq rest) point-seq))
  115.       (:else       
  116.        point-seq))))
  117.  
  118.  
  119.  
  120. ;;;----------------------------------------------------------------------------+
  121. ;;;                                                                            |
  122. ;;;                            Event Translations                              |
  123. ;;;                                                                            |
  124. ;;;----------------------------------------------------------------------------+
  125.  
  126. (DEFEVENT sketchpad (:button-release :button-1) enter-point)
  127. (DEFEVENT sketchpad :motion-notify              move-point)
  128. (DEFEVENT sketchpad :leave-notify               finish-points)
  129.  
  130.  
  131. (defun enter-point (sketchpad)
  132.   (WITH-EVENT (x y)
  133.     (with-slots (in-progress-p next-x next-y) sketchpad
  134.  
  135.       ;; Is this point the same as the last one entered?
  136.       (if (and in-progress-p
  137.            (= x (last-x in-progress-p))
  138.            (= y (last-y in-progress-p)))
  139.  
  140.       ;; Yes, complete element.
  141.       (end-points sketchpad)
  142.       
  143.       ;; No, update point list with new point.
  144.       (setf in-progress-p (nconc (list x y) in-progress-p)
  145.         next-x        nil
  146.             next-y        nil)))))
  147.  
  148.  
  149. (defun end-points (sketchpad)
  150.   (with-slots (mode) sketchpad
  151.     ;; Complete element in current mode.
  152.     (finish-element sketchpad mode)))
  153.  
  154. (defun finish-points (sketchpad)
  155.   (with-slots (in-progress-p mode) sketchpad
  156.     (when in-progress-p
  157.       ;; Undisplay last rubberband line.
  158.       (display-next-point sketchpad mode)
  159.  
  160.       ;; Complete element.
  161.       (end-points sketchpad))))
  162.  
  163. (defun move-point (sketchpad)
  164.   (WITH-EVENT (x y)
  165.     (with-slots (next-x next-y mode in-progress-p) sketchpad
  166.  
  167.       ;; Ignore if first point not yet entered.
  168.       (when in-progress-p
  169.         ;; Undisplay last rubberband line.
  170.         (when next-x
  171.           (display-next-point sketchpad mode))
  172.         
  173.         ;; Update next point.
  174.         (setf next-x x next-y y)
  175.         
  176.         ;; Display next rubberband line.
  177.         (display-next-point sketchpad mode)))))
  178.  
  179.  
  180. (defmethod finish-element ((sketchpad sketchpad) mode)
  181.   (with-slots (in-progress-p picture) sketchpad
  182.     ;; Restore point list to order entered.
  183.     (setf in-progress-p (nreverse-point-seq in-progress-p))
  184.     
  185.     ;; Erase all old rubberband lines.
  186.     (clear-in-progress sketchpad mode)
  187.  
  188.     ;; Add new element to display list.
  189.     (let ((element (add-element sketchpad mode)))
  190.       (when element
  191.     (setf picture (nconc picture (list element)))))
  192.     
  193.     ;; Get ready to begin next element.
  194.     (setf in-progress-p nil)))
  195.  
  196.  
  197.     
  198.  
  199. ;;;----------------------------------------------------------------------------+
  200. ;;;                                                                            |
  201. ;;;                                 Line Mode                                  |
  202. ;;;                                                                            |
  203. ;;;----------------------------------------------------------------------------+
  204.  
  205.  
  206. (xlib::def-clx-class (line)
  207.   (points)
  208.   (width))
  209.       
  210. (defmethod add-element ((sketchpad sketchpad) (mode (eql :line)))
  211.   (with-slots (in-progress-p line-width) sketchpad
  212.     (unless (< (point-seq-length in-progress-p) 2)
  213.       (let ((new-line (make-line
  214.             :width  line-width
  215.             :points in-progress-p)))
  216.     (draw-element sketchpad new-line)
  217.     new-line))))
  218.  
  219.  
  220. (defmethod clear-in-progress ((sketchpad sketchpad) mode)
  221.   (declare (ignore mode))
  222.   (with-slots (in-progress-p line-width) sketchpad
  223.     (USING-GCONTEXT (gcontext
  224.               :drawable   sketchpad
  225.               :line-width line-width
  226.               :foreground (logxor (CONTACT-FOREGROUND sketchpad)
  227.                       (CONTACT-CURRENT-BACKGROUND-PIXEL sketchpad))
  228.               :function   boole-xor)
  229.       (do* ((from-x (first in-progress-p)  to-x)
  230.         (from-y (second in-progress-p) to-y)
  231.         (points (cddr in-progress-p)   (cddr points))
  232.         (to-x   (first points)         (first points))
  233.         (to-y   (second points)        (second points)))
  234.        ((endp points))
  235.     (draw-line sketchpad gcontext from-x from-y to-x to-y)))))
  236.  
  237. (defmethod display-next-point ((sketchpad sketchpad) mode)
  238.   (declare (ignore mode))
  239.   (with-slots (line-width next-x next-y in-progress-p) sketchpad
  240.     (USING-GCONTEXT (gcontext
  241.               :drawable   sketchpad
  242.               :line-width line-width
  243.               :foreground (logxor (CONTACT-FOREGROUND sketchpad)
  244.                       (CONTACT-CURRENT-BACKGROUND-PIXEL sketchpad))
  245.               :function   boole-xor)
  246.       (draw-line sketchpad gcontext
  247.          (last-x in-progress-p) (last-y in-progress-p)
  248.          next-x next-y))))
  249.  
  250. (defmethod draw-element ((sketchpad sketchpad) (element line))
  251.   (USING-GCONTEXT (gcontext
  252.             :drawable   sketchpad
  253.             :line-width (line-width element)
  254.             :foreground (CONTACT-FOREGROUND sketchpad))
  255.     (draw-lines sketchpad gcontext (line-points element))))
  256.  
  257. (defmethod intersect-p ((element line) x y width height)
  258.   (let*
  259.     ((points (line-points element))
  260.      (min-x  (point-seq-x points 0))
  261.      (max-x  min-x)
  262.      (min-y  (point-seq-y points 0))
  263.      (max-y  min-y))
  264.     (dotimes (i (point-seq-length points))
  265.       (setf
  266.     min-x (min min-x (point-seq-x points i))
  267.     max-x (max max-x (point-seq-x points i))
  268.     min-y (min min-y (point-seq-y points i))
  269.     max-y (max max-y (point-seq-y points i))))    
  270.     (and
  271.       (>= max-x x)
  272.       (>= max-y y)
  273.       (<  min-x (+ x width))
  274.       (<  min-y (+ y height)))))
  275.  
  276.  
  277.  
  278. ;;;----------------------------------------------------------------------------+
  279. ;;;                                                                            |
  280. ;;;                               Polygon Mode                                 |
  281. ;;;                                                                            |
  282. ;;;----------------------------------------------------------------------------+
  283.  
  284. (xlib::def-clx-class (polygon (:include line))
  285.   (fill))
  286.       
  287. (defmethod add-element ((sketchpad sketchpad) (mode (eql :polygon)))
  288.   (with-slots (in-progress-p line-width fill) sketchpad
  289.     (unless (< (point-seq-length in-progress-p) 3)
  290.       (let ((new-polygon (make-polygon
  291.                :width  line-width
  292.                :fill   fill
  293.                :points in-progress-p)))
  294.     (draw-element sketchpad new-polygon)
  295.     new-polygon))))
  296.  
  297.  
  298.  
  299. (defmethod draw-element ((sketchpad sketchpad) (element polygon))
  300.   (let ((foreground (CONTACT-FOREGROUND sketchpad)))
  301.     (USING-GCONTEXT (gcontext
  302.               :drawable   sketchpad
  303.               :fill-style :tiled
  304.               :tile       (CONTACT-IMAGE-MASK
  305.                     sketchpad (symbol-value (polygon-fill element))
  306.                     :foreground foreground
  307.                     :background (CONTACT-CURRENT-BACKGROUND-PIXEL sketchpad)))
  308.       
  309.       ;; Fill interior
  310.       (draw-lines sketchpad gcontext (line-points element) :fill-p t)
  311.       
  312.       ;; Draw boundary
  313.       (with-gcontext (gcontext
  314.                :fill-style :solid
  315.                :line-width (polygon-width element)
  316.                :foreground foreground)
  317.     (draw-lines sketchpad gcontext (line-points element))
  318.     (let ((last  (1- (point-seq-length (line-points element)))))
  319.       (draw-line  sketchpad gcontext
  320.               (point-seq-x (line-points element) last) (point-seq-y (line-points element) last)
  321.               (point-seq-x (line-points element) 0) (point-seq-y (line-points element) 0)))))))
  322.  
  323.  
  324.  
  325.